Creating Mailing Labels from an Outlook Contact List Using Word

Creating Mailing Labels from an Outlook Contact List Using Word

This section shows you how to create mailing labels from an Outlook Contact list using the MailMerge object in Word. Word recognizes a wide variety of mailing labels. These label types are identified by string names. You can get a list of the label types available by clicking Envelopes and Labels on the Tools menu, clicking the Labels tab, clicking Options, and then examining the Product number list box.

The CreateContactsLabels procedure, shown below, creates the mailing labels. It first inserts text and placeholder strings into a document. It calls the subroutine, FormatRange, to prepare a Range object with the fields needed for the mailing labels. FormatRange is sent a MailMergeFields collection object. It finds and replaces each placeholder string,phField, with the appropriate mail merge field. Using placeholders guarantees that the MailMerge fields are inserted exactly where you want.

The CreateContactLabels procedure then stores the range as an AutoText entry. It uses the CreateNewDocument method of the MailingLabel object to create the mailing labels based on the AutoText entry.

The CreateContactLabels procedure also shows how the DataSource object can be used to filter or sort records. This object's QueryString property is filled with an SQL string before the MailMerge object is executed.

When you call the CreateContactLabels procedure, you need to supply a string that names the specific label type. For example, to create Avery 5160 labels, use the following code:

CreateContactsLabels "5160"

The sample code for this section is in the template WrdSamp.dot. To run the sample code, copy WrdSamp.dot to your Office Templates directory, create a new document based on the WrdSamp.dot template, and click Quick Labels on the Tools menu. Choose a label from the drop-down list box, and then click Create Labels.

Note Because CreateContactsLabels works with the MailMerge object, it can create mailing labels from the Outlook Contacts folder without a reference to the Outlook object library.

Public Sub CreateContactsLabels(strLabelName As String)

	Dim docMergeDoc As Document
	Dim rngRange As Range
	Dim strSQL As String
	Dim intCurrentField As Integer
	Dim strMessage As String

	Const MESSAGE_CAPTION = "Creating Mailing Labels for Contacts"
	Const LABEL_NOT_FOUND = 5843

	On Error GoTo Err_CreateContactsLabels

	'Add a new document and set a reference to it.
	Set docMergeDoc = Documents.Add

	With docMergeDoc.MailMerge
		'Set values for mailing labels mail merge based on
		'Outlook Address Book (olk).
		.MainDocumentType = wdMailingLabels
		.UseAddressBook Type:="olk"

		'Prepare a range with string placeholders (phField) for MailMerge 
		'fields.
		Set rngRange = docMergeDoc.Range
		With rngRange
			.InsertAfter "phField phField"
			.InsertParagraphAfter
			.InsertAfter "phField"
			.InsertParagraphAfter
			.InsertAfter "phField, phField phField"
		End With
		
	'Add the MailMerge fields calling FormatRange.
	FormatRange .Fields

	'Copy the range to an AutoTextEntry.
	NormalTemplate.AutoTextEntries.Add "LabelText", rngRange

	'Create a mailing label template using AutoTextEntry.
	Application.MailingLabel.CreateNewDocument Name:=strLabelName, _
					Address:="", AutoText:="LabelText"

	.Destination = wdSendToNewDocument
	.SuppressBlankLines = True

	With .DataSource
		strSQL = "SELECT * FROM " & .Name
		strSQL = strSQL & " ORDER BY Last_Name"
		.QueryString = strSQL
		.FirstRecord = wdDefaultFirstRecord
		.LastRecord = wdDefaultLastRecord
	End With
	.Execute
	
	'Close docMergeDoc without saving changes. 
	docMergeDoc.Close SaveChanges:=wdDoNotSaveChanges
End With

'The AutoTextEntry is no longer needed so delete it.
NormalTemplate.AutoTextEntries("LabelText").Delete

'Activate and save the labels. Microsoft Word adds the new
'document to the beginning of the Documents collection. 
Documents(1).Activate
	With Dialogs(wdDialogFileSaveAs)
		.Name = "ContactLabels.doc"
		.Show
	End With
	
Exit_CreateContactsLabels:
	On Error Resume Next

	Set rngRange = Nothing
	Set docMergeDoc = Nothing

	Exit Sub 
Err_CreateContactsLabels:
	If Err = LABEL_NOT_FOUND Then
		strMessage = "'" & strLabelName & "' is not a recognized label name!"
		Else
			strMessage = "An unexpected error, #" & Err & " : " & Error _
							" has occured."
	End If
	MsgBox strMessage, vbCritical, MESSAGE_CAPTION
	Resume Exit_CreateContactsLabels
	
End Sub

The FormatRange procedure is called by
CreateContactLabelsto replace the string placeholders with mail merge fields.

Private Sub FormatRange(mgfFields As MailMergeFields)

	Dim strFieldName As String
	Dim intCurrentField As Integer
	Dim rngRange As Range
	Dim docMergeDoc As Document

	Set docMergeDoc = mgfFields.Parent.Parent

	For intCurrentField = 0 To 5
		Set rngRange = docMergeDoc.Range

		'Look for phField.
		With rngRange.Find
			.MatchWholeWord = True
			.Execute FindText:="phField"

			'If phField is found, use intCurrentField to determine which 
			'field to insert and then add the field.
			If .Found Then
				Select Case intCurrentField
					Case 0
						strFieldName = "First_Name"
					Case 1
						strFieldName = "Last_Name"
					Case 2
						strFieldName = "Street_Address"
					Case 3
						strFieldName = "City"
					Case 4
						strFieldName = "State_or_Province"
					Case 5
						strFieldName = "Postal_Code"
				End Select
				mgfFields.Add Range:=rngRange, Name:=strFieldName
			End If
		End With
	Next intCurrentField

	Set rngRange = Nothing
	Set docMergeDoc = Nothing
End Sub